home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / adaed-1.11 / adaed-1 / Adaed-1.11.0a / 12c.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  38.8 KB  |  1,385 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. /* chapter 12, part c */
  10. #include "hdr.h"
  11. #include "vars.h"
  12. #include "attr.h"
  13. #include "dbxprots.h"
  14. #include "dclmapprots.h"
  15. #include "miscprots.h"
  16. #include "smiscprots.h"
  17. #include "setprots.h"
  18. #include "nodesprots.h"
  19. #include "errmsgprots.h"
  20. #include "chapprots.h"
  21.  
  22. /* ctype.h needed by desig_to_op */
  23. #include <ctype.h>
  24.  
  25. static Tuple instantiation_code;        /* code from instantiation */
  26. static int instantiation_code_n = 0;    /* current length */
  27.  
  28. static Node instantiate_object(Node, Symbol, Symbolmap);
  29. static int can_rename(Node);
  30. static Tuple flatten_tree(Node);
  31. static int is_discr_ref(Node, Tuple);
  32. static Symbol instantiate_type(Node, Symbol, Symbolmap);
  33. static Symbol valid_type_instance(Symbol, Symbol, Symbolmap);
  34. static Symbol valid_scalar_instance(Symbol, Symbol, Symbolmap);
  35. static void check_actual_constraint(Symbol, Symbol);
  36. static Symbol valid_priv_instance(Symbol, Symbol, Symbolmap);
  37. static Symbol valid_access_instance(Symbol, Symbol, Symbolmap);
  38. static Symbol valid_array_instance(Symbol, Symbol, Symbolmap);
  39. static int is_valid_disc_instance(Symbol, Symbol, Symbolmap);
  40. static Tuple get_array_info(Symbol);
  41. static void generic_subprog_instance(Node, Symbol, Symbolmap, int);
  42. static Tuple find_renamed_types(int, Tuple, Symbol, Node);
  43. static Node make_rename_node(Symbol, Node);
  44. static void instantiation_code_with(Node);
  45.  
  46. /* number of slots to expand instantiation_code when full, initial alloc*/
  47. #define INSTANTIATION_CODE_INC    50
  48.  
  49. Tuple instantiate_generics(Tuple gen_list, Node instance_node)
  50.   /*;instantiate_generics*/
  51. {
  52.     /* Produce the list of renamings which transforms generic parameters
  53.      * into actual ones.
  54.      * Generic types play a special role in this renaming. We collect the
  55.      * Instantiations of generic types into the map     -type_map-and use it
  56.      * in a substitution procedure to obtain the signature of generic
  57.      * subprogram arguments.
  58.      * Generic subprograms are also renamed by the actual subprograms, and
  59.      * the mapping from one to the other is also added to the same renaming
  60.      * map.
  61.      */
  62.  
  63.     Tuple    error_instance, empty_tuple, inst_code;
  64.     Symbolmap    type_map, empty_typemap;
  65.     Tuple    gtup;
  66.     Tuple    instance, new_instance;
  67.     int        i, j, k, gn, ni, seen;
  68.     Node    assoc;
  69.     int        first_named, exists, is_default;
  70.     Symbol    g_name, name;
  71.     Node    actual;
  72.     Symbol    actual_type;
  73.     Node    init_node;
  74.     Node    id_node;
  75.     Tuple    tup;
  76.     int        nat;
  77.     Fortup    ft1;
  78.  
  79.     if( cdebug2 > 3) TO_ERRFILE("AT PROC :  instantiate_generics ");
  80.  
  81.     /*    const error_instance = [ [], {} ];        $$ES7 */
  82.     instantiation_code = tup_new(0);
  83.     instantiation_code_n = 0;
  84.     type_map = symbolmap_new();
  85.     empty_tuple = tup_new(0);
  86.     empty_typemap = symbolmap_new();
  87.     error_instance = tup_new2((char *) empty_tuple, (char *) empty_typemap);
  88.     instance = N_LIST(instance_node);
  89.  
  90.     if (tup_size( instance) > tup_size( gen_list)){
  91. #ifdef ERRNUM
  92.         errmsgn(60, 58, instance_node);
  93. #else
  94.         errmsg("Too many actuals in generic instantiation", "12.3", instance_node);
  95. #endif
  96.     }
  97.  
  98.     /* Values may be supplied either positionally or by name.  */
  99.     exists = FALSE;
  100.     FORTUPI(assoc=(Node), instance, i, ft1);
  101.         if (N_AST1(assoc) != OPT_NODE){
  102.             exists = TRUE;
  103.             break;
  104.         }
  105.     ENDFORTUP(ft1);
  106.     if (exists) {
  107.         first_named = i;
  108.         exists = FALSE;
  109.         for (k=i; k <= tup_size(instance); k++) {
  110.             if (N_AST1((Node)instance[k]) == OPT_NODE){
  111.                 exists = TRUE;
  112.                 break;
  113.             }
  114.         }
  115.         if (exists) {
  116. #ifdef ERRNUM
  117.             errmsgn(61, 58, (Node)instance[k]);
  118. #else
  119.             errmsg("Positional association after named one", "12.3",
  120.               (Node)instance[k]);
  121. #endif
  122.             return error_instance;
  123.         }
  124.     }
  125.     else
  126.         first_named = tup_size(instance) + 1;
  127.     seen = first_named - 1;
  128.     new_instance = tup_new(0);
  129.     for (i = 1; i <= seen; i++) {
  130.         actual = N_AST2((Node)instance[i]);
  131.         new_instance = tup_with(new_instance, (char *) actual);
  132.     }
  133.  
  134.     /* Collect named instances in the proper order.*/
  135.     gn = tup_size(gen_list);
  136.     for (i=first_named; i <= gn; i++) {
  137.         gtup = (Tuple) gen_list[i];
  138.         g_name = (Symbol) gtup[1];
  139.         init_node = (Node) gtup[2];
  140.         exists = FALSE;
  141.         ni = tup_size(instance);
  142.         for (j=first_named; j <= ni; j++) {
  143.             id_node = N_AST1((Node) instance[j]);
  144.             if (id_node == OPT_NODE) continue;
  145.             if (streq(N_VAL(id_node), ORIG_NAME(g_name))) {
  146.                 exists = TRUE;
  147.                 break;
  148.             }
  149.         }
  150.         if (exists) {
  151.             actual = N_AST2((Node) instance[j]);
  152.             new_instance = tup_with(new_instance, (char *) actual);
  153.             seen += 1;
  154.  
  155.             if(NATURE(g_name) == na_procedure || NATURE(g_name) == na_function){
  156.                 name = dcl_get(DECLARED(SCOPE_OF(g_name)), N_VAL(id_node));
  157.                 if (set_size(OVERLOADS(name)) > 1)
  158. #ifdef ERRNUM
  159.                     errmsgn(62, 63, id_node);
  160. #else
  161.                     errmsg(
  162.                       "named associations not allowed for overloaded names",
  163.                       "12.3(3)", id_node);
  164. #endif
  165.             }
  166.             /* Otherwise a default must exist for this generic parameter.*/
  167.             /* Mark the place for use below.*/
  168.         }
  169.         else if (init_node != OPT_NODE ) 
  170.             new_instance = tup_with(new_instance, (char *) OPT_NODE);
  171.         else {
  172. #ifdef ERRNUM
  173.             id_errmsgn(64, g_name, 58, current_node);
  174. #else
  175.             errmsg_id("Missing instantiation for generic parameter %" ,
  176.               g_name, "12.3", current_node);
  177. #endif
  178.             return error_instance;
  179.         }
  180.     }
  181. #ifdef TBSN
  182.     if (cdebug2 > 0){
  183.         TO_ERRFILE('new instance ' + str new_instance);
  184.     }
  185. #endif
  186.     /* Now process all actuals in succession. */
  187.     gn = tup_size(gen_list);
  188.     for (i = 1; i <= gn; i++) {
  189.         gtup= (Tuple) gen_list[i];
  190.         g_name = (Symbol) gtup[1];
  191.         init_node = (Node) gtup[2];
  192.         actual = (Node) new_instance[i];
  193.  
  194.         if (actual != OPT_NODE ) {
  195.             adasem(actual);
  196.             if (NATURE(g_name) == na_in) {
  197.                 /* type check expression for in parameter. */
  198.                 actual_type = replace(TYPE_OF(g_name), type_map);
  199.                 check_type(actual_type, actual);
  200.             }
  201.             else if (NATURE(g_name)== na_procedure
  202.               || NATURE(g_name)== na_function) {
  203.                 /* Actual may be given by an operator symbol, which appear  */
  204.                 /*  as string literal. */
  205.                 is_default = FALSE;
  206.                 if (N_KIND(actual) == as_string_literal)
  207.                     desig_to_op(actual);
  208.                 find_old(actual);
  209.             }
  210.         }
  211.         else {
  212.             /* Use default value given.*/
  213.             actual = init_node;
  214.             if (NATURE(g_name) == na_in )
  215.                 /* May depend on generic types: replace by their instances.*/
  216.                 actual = instantiate_tree(init_node, type_map);
  217.             else    {        /* generic subprogram parameter */
  218.                 /* If the box was used to specify a default subprogram, we
  219.                  * retrieve the visible instances of the generic identifier.
  220.                  */
  221.                 is_default = TRUE;
  222.                 if (N_KIND(actual) == as_simple_name
  223.                   && streq(N_VAL(actual), "box")) {
  224.                     actual = node_new(as_simple_name);
  225.                     N_VAL(actual) = original_name(g_name);
  226.                     copy_span(instance_node, actual);
  227.                     find_old(actual);
  228.                     is_default = FALSE;
  229.                 }
  230.                 else if (N_KIND(actual) == as_attribute)
  231.                     /* Will depend on generic types. Must instantiate. */
  232.                     actual = instantiate_tree(init_node, type_map);
  233.             }
  234.         }
  235.         nat = NATURE(g_name);
  236.         if (nat == na_in || nat == na_inout)
  237.             /* TBSL: see if instantiation_code might be large in which case
  238.              * may want to avoid too many tup_with calls
  239.              */
  240.             instantiation_code_with(
  241.               instantiate_object(actual, g_name, type_map));
  242.         else if (nat == na_procedure || nat == na_function)
  243.             generic_subprog_instance(actual, g_name, type_map, is_default);
  244.         else {            /* generic type. */
  245.             actual_type = instantiate_type(actual, g_name, type_map);
  246.             if (actual_type == (Symbol)0)
  247.                 return error_instance;
  248.             else {
  249.                 symbolmap_put(type_map, g_name, actual_type);
  250.                 if (is_scalar_type(g_name))
  251.                     /* indicate the instantiation of its base type as well. */
  252.                     symbolmap_put(type_map, TYPE_OF(g_name),
  253.                       base_type(actual_type));
  254.             }
  255.         }
  256.     }
  257.     if (seen != tup_size(instance)) {
  258.         /* Not all named associations were processed.*/
  259. #ifdef ERRNUM
  260.         errmsgn(65, 58, current_node);
  261. #else
  262.         errmsg("duplicate or erroneous named associations in instantiation",
  263.           "12.3", current_node);
  264. #endif
  265.     }
  266.  
  267.     if (cdebug2 > 0 ) TO_ERRFILE("Type map: ");
  268.     /* Attach newly created declarative nodes to the instance node itself
  269.      * so that AST tree remains connected (separate compilation need).
  270.      * TBSL: check whether this trick is still necessary now that the node
  271.      * stack (in save_tree) is initialized with all nodes in unit_nodes
  272.      */
  273.     inst_code = tup_new(instantiation_code_n);
  274.     for (i = 1; i <= instantiation_code_n; i++)
  275.         inst_code[i] = instantiation_code[i];
  276.     N_LIST(instance_node) = tup_add(N_LIST(instance_node), inst_code);
  277.     tup = tup_new(2);
  278.     /* TBSL: is tup_copy needed below since i...code also include in N_LIST*/
  279.     tup[1]= (char *) inst_code;
  280.     tup[2] = (char *) type_map;
  281.     return tup;
  282. }
  283.  
  284. void desig_to_op(Node node)            /*;desig_to_op*/
  285. {
  286.     /* a designator appears syntactically as a string literal. Verify that it
  287.      * does designate a valid operator symbol.
  288.      */
  289.  
  290.     char    *op_name, *p;
  291.  
  292.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  desig_to_op");
  293.  
  294.     N_KIND(node) = as_simple_name;
  295.     /*op_name := +/[to_lower(c) ? c : c in N_VAL(node)];*/
  296.     op_name = strjoin(N_VAL(node), ""); /* copy operator name */
  297.     for (p = op_name; *p; p++)  /* fold name to lower case*/
  298.         if (isupper(*p)) *p = tolower(*p);
  299.     if (in_op_designators(op_name))
  300.         N_VAL(node) = (char *) op_name;
  301.     else {
  302. #ifdef ERRNUM
  303.         str_errmsgn(66, op_name, 67, node);
  304. #else
  305.         errmsg_str("% is not an operator designator", op_name, "4.5", node);
  306. #endif
  307.         N_VAL(node) = string_any_id; /* "any_id" */
  308.     }
  309. }
  310.  
  311. static Node instantiate_object(Node actual_node, Symbol g_name,
  312.   Symbolmap type_map)                        /*;instantiate_object*/
  313. {
  314.     int        g_mode;
  315.     Symbol    g_type, actual_type;
  316.     Node    d, n, i, t;
  317.     Symbol    actual_name;
  318.     Tuple    tup;
  319.  
  320.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : instantiate_object");
  321.  
  322.     /* Unpack information about generic parameter.*/
  323.     g_mode = NATURE(g_name);
  324.     g_type = TYPE_OF(g_name);
  325.  
  326.     actual_type = symbolmap_get(type_map, g_type);
  327.     /* If generic. */
  328.     if (actual_type == (Symbol)0) actual_type = g_type;
  329.     /* Otherwise. */
  330.     /* For each instantiation we must create locations for the generic
  331.      * parameters, and replace in the body of the object the generic ones
  332.      * with the actual ones.
  333.      */
  334.  
  335. #ifdef TBSN
  336.     actual_name = prefix + original_name(g_name) + str newat;
  337. #endif
  338.     actual_name = sym_new(na_void);
  339.     ORIG_NAME(actual_name) = ORIG_NAME(g_name);
  340.     symbolmap_put(type_map, g_name, actual_name);
  341.  
  342.     if (g_mode == na_in) {
  343.         /* Expression has already been type_checked*/
  344.         if (is_deferred_constant(actual_node)) {
  345. #ifdef ERRNUM
  346.             l_errmsgn(68, 69, 43, actual_node);
  347. #else
  348.             errmsg_l("Instantiation of a generic in parameter cannot be a ",
  349.               " deferred constant", "7.4.3", actual_node);
  350. #endif
  351.             return OPT_NODE;
  352.         }
  353.         NATURE(actual_name) = na_constant;
  354.         TYPE_OF(actual_name) = actual_type;
  355.         SIGNATURE(actual_name) = (Tuple) actual_node;
  356.         /* Build declaration tree for it.  */
  357.         d = node_new(as_const_decl);
  358.         n = node_new(as_list);
  359.         i = node_new(as_simple_name);
  360.         t = node_new(as_simple_name);
  361.         N_UNQ(i) = actual_name;
  362.         N_UNQ(t) = actual_type;
  363.         N_LIST(n) = tup_new1((char *) i);
  364.         N_AST1(d) = n;
  365.         N_AST2(d) = t;
  366.         N_AST3(d) = actual_node;
  367.         return  d;
  368.     }
  369.     else {                        /* in out parameter. */
  370.         TYPE_OF(actual_name) = actual_type;
  371.         SIGNATURE(actual_name) = (Tuple) OPT_NODE;
  372.         if (N_KIND(actual_node) != as_name) {
  373. #ifdef ERRNUM
  374.             errmsgn(70, 71, actual_node);
  375. #else
  376.             errmsg(
  377.               "Instantiation of generic in out parameter must be a variable",
  378.               "12.1.1, 12.3.1", actual_node);
  379. #endif
  380.             return OPT_NODE;
  381.         }
  382.         else {
  383.             find_old(actual_node);
  384.         }
  385.  
  386.         if (N_KIND(actual_node) == as_convert) {
  387. #ifdef ERRNUM
  388.             l_errmsgn(72, 73, 74, actual_node);
  389. #else
  390.             errmsg_l("Instantiation of generic in out parameter ",
  391.               "cannot be a conversion", "12.3.1", actual_node);
  392. #endif
  393.             return OPT_NODE;
  394.         }
  395.         out_context = FALSE;
  396.  
  397.         check_type(base_type(actual_type), actual_node);
  398.         tup = check_nat_type(actual_node);
  399.         NATURE(actual_name) = (int) tup[1];
  400.         SCOPE_OF(actual_name) = scope_name;
  401.  
  402.         /* actual_name carries the type of the actual, not the renamed formal.*/
  403.         /* remove spurious constraint that may have been imposed by check_type*/
  404.  
  405.         if (in_qualifiers(N_KIND(actual_node)))
  406.             actual_node = N_AST1(actual_node);
  407.         if (N_KIND(actual_node) == as_simple_name)
  408.             /* should deal with general name here. */
  409.             TYPE_OF(actual_name) = TYPE_OF(N_UNQ(actual_node));
  410.  
  411.         if (!is_variable(actual_node)){
  412. #ifdef ERRNUM
  413.             l_errmsgn(72, 75, 71, actual_node);
  414. #else
  415.             errmsg_l("Instantiation of generic in out parameter ",
  416.               "must be a variable", "12.1.1, 12.3.1", actual_node);
  417. #endif
  418.             return OPT_NODE;
  419.         }
  420.         /*TBSL: SETL has is_dis(actual), substituting actual_node */
  421.         else if ( ! can_rename( actual_node )) {
  422. #ifdef ERRNUM
  423.             l_id_errmsgn(76, 77, g_name, 74, actual_node);
  424. #else
  425.             errmsg_l_id(
  426.               "instantiation of generic in out parameter % depends on a ",
  427.               "discriminant", g_name, "12.3.1", actual_node);
  428. #endif
  429.             return OPT_NODE;
  430.         }
  431.         else {
  432.             /* Build a renaming declaration for object.
  433.              * Possible optimization if actual is simple name (later).
  434.              */
  435.             d = node_new(as_rename_obj);
  436.             i = new_name_node(actual_name);
  437.             N_AST1(d) = i;
  438.             N_AST2(d) = OPT_NODE;
  439.             N_AST3(d) = actual_node;
  440.             return d;
  441.         }
  442.     }
  443. }
  444.  
  445. static int can_rename(Node obj)                        /*;can_rename */
  446. {
  447.     /* This procedure detects illegal  dependence on discriminants for renamed
  448.      * variables  and in out  generic parameters, as  defined  in 8.5(7).  The
  449.      * expression is  linearized  and subsequent retrievals examined to detect
  450.      * subcomponents whose existence depends on outer discriminants. The first
  451.      * retrieval is the only  one that can apply to an unconstrained variable.
  452.      */
  453.  
  454.     Tuple    seq, discrs, discr_map;
  455.     Node    var_node, sel_node, first, node, lo, hi;
  456.     Symbol    var_name, var_type, selector, comp_type, i;
  457.     int    d, dsize;
  458.     Fortup    ft;
  459.  
  460.     seq = (Tuple) flatten_tree(obj);
  461.     if (tup_size(seq) == 0) return TRUE;
  462.     first = (Node) seq[tup_size(seq)];
  463.  
  464.     var_node = N_AST1(first);
  465.     sel_node = N_AST2(first);
  466.  
  467.     /* The first prefix is a simple name, an allocator, or a function call.
  468.      * We only consider simple names here.
  469.      */
  470.     if (N_KIND(var_node) != as_simple_name ) return TRUE;
  471.  
  472.     var_name = N_UNQ(var_node);
  473.     var_type = TYPE_OF(var_name);
  474.  
  475.     if ( can_constrain(var_type)) {
  476.         /* Any dependence on its discriminants will be illegal.
  477.          * TBSL: a generic in out parameter.
  478.          */
  479.         discrs = discriminant_list(var_type);
  480.         if (is_formal(var_name) ) {
  481.             FORTUP(i=(Symbol), discrs, ft)
  482.                 if (default_expr(i) == (Tuple) OPT_NODE) {
  483.                     discrs = tup_new(0);
  484.                     break;
  485.                 }
  486.             ENDFORTUP(ft);
  487.         }
  488.     }
  489.     else
  490.         discrs = tup_new(0);
  491.  
  492.     /* other dependence is if subtype indication of subcomponent
  493.     * depends on discriminants of variable, or on discriminants of
  494.     * inner constrainable components.
  495.     */
  496.     while (tup_size(seq) != 0) {
  497.         node = (Node) tup_frome(seq);
  498.         if (N_KIND(node) == as_selector) {
  499.             sel_node = N_AST2(node);
  500.             comp_type = TYPE_OF(N_UNQ(sel_node));
  501.         }
  502.         else
  503.             /* other subcomponents cannot depend on discriminants */
  504.             return TRUE;
  505.         selector = N_UNQ(sel_node);
  506.         if (tup_size(discrs) != 0 && !tup_mem((char *)selector,
  507.           build_comp_names((Node) invariant_part(var_type))))
  508.             /* component is in variant part: illegal renaming. */
  509.             return FALSE;
  510.         if (is_array(comp_type)) {
  511.             FORTUP(i=(Symbol), index_types(comp_type), ft)
  512.                 lo = (Node) SIGNATURE(i)[2];
  513.                 hi = (Node) SIGNATURE(i)[3];
  514.                 if (is_discr_ref(lo, discrs) || is_discr_ref(hi, discrs))
  515.                     return FALSE;
  516.             ENDFORTUP(ft);
  517.         }
  518.         else if (is_record(comp_type)) {
  519.             if (NATURE(comp_type) == na_subtype) {
  520.                 discr_map = (Tuple) numeric_constraint_discr(
  521.                   SIGNATURE(comp_type));
  522.                 /* if exists node in range discr_map |
  523.                  *    is_discr_ref(node, discrs) then     return false; end if;
  524.                  */
  525.                 dsize = tup_size(discr_map);
  526.                 for (d = 1; d <= dsize; d += 2 ) {
  527.                     node = (Node) discr_map[d+1];
  528.                     if (is_discr_ref(node, discrs))
  529.                         return FALSE;
  530.                 }
  531.                 discrs = tup_new(0);
  532.             }
  533.             else    {
  534.                 discrs = discriminant_list(comp_type);
  535.                 var_type = comp_type;  /* for inner subcomponents */
  536.             }
  537.         }
  538.         else return TRUE;        /* scalar component */
  539.     }
  540.     /* If we exit, no discriminant dependence was found. */
  541.     return TRUE;
  542. }
  543.  
  544. static Tuple flatten_tree(Node expn)                /*;flatten_tree */
  545. {
  546.     /* In order to determine whether a subcomponent depends on a discriminant,
  547.      * it is easiest  to simulate  in order     the sequence of  retrievals  that
  548.      * yields that subcomponent. Only nodes that retrieve  components are kept.
  549.      */
  550.  
  551.     Node prefix;
  552.     int kind;
  553.  
  554.     kind = N_KIND(expn);
  555.     if (kind == as_selector ||kind == as_index || kind == as_slice) {
  556.         prefix = N_AST1(expn);
  557.         return (tup_add(tup_new1((char *)expn), flatten_tree(prefix)));
  558.     }
  559.     else
  560.         return tup_new(0);
  561. }
  562.  
  563. static int is_discr_ref(Node node, Tuple discrs)        /*;is_discr_ref */
  564. {
  565.  
  566.     if (N_KIND(node) != as_discr_ref)
  567.         return FALSE;
  568.     else
  569.         return tup_mem((char *) N_UNQ(node), discrs);
  570. }
  571.  
  572. /* THIS IS OBSOLETE !!! */
  573. int is_discriminant_dependent(Node  expn)  /*;is_discriminant_dependent*/
  574. {
  575.     /*   Function :
  576.      *     this (non-recursive) procedure accepts as parameter an
  577.      *     expression that has been parsed as a valid 'name', and
  578.      *     return true if the existence of the object designated
  579.      *     may depend on a discriminant. See LRM 8.5, 3.7.1, 12.3.1.
  580.      *   Usage :
  581.      *     for generic in out parameter
  582.      *     for renaming
  583.      */
  584.  
  585. /*  comment out for less warning messages from  CC
  586.     Tuple    lexpn;
  587.     Symbol    first;
  588.     int        is_first_element;
  589.     Symbol    current_type;
  590.     Tuple    discr;
  591.     Symbol    op_name, base_type_rec, field_name, name;
  592.     Tuple    nam_list;
  593.     Tuple    bounds;
  594.     Symbol    i;
  595. */
  596.     /* lo, hi, bound */
  597.  
  598.     if (cdebug2 > 3)
  599.         TO_ERRFILE("AT PROC : is_discriminant_dependent ( + str expn + )");
  600.  
  601.     return    FALSE;      /* $$$ FOR NOW */
  602.     /*****************************************************/
  603.     /*   the expression is first 'flattened' : */
  604.  
  605.     /* Ihave changed expn to lexpn as lexpn must be flattened */
  606. #ifdef TBSN
  607.     lexpn = linear(expn);
  608.     first fromb lexpn;
  609.     is_first_element =  TRUE;
  610.     current_type = TYPE_OF( first );
  611.     discr = tup_new(0);
  612.  
  613.     /*  the guess along that loop is that it is not dependent : */
  614.     ( while (lexpn?[]) /= [] )
  615.     case op_name fromb lexpn of
  616.  
  617.         /*
  618.  *  Record case : check that component is in fixed part
  619.  *          keep discriminants in case of array component
  620.  */
  621.         ('.'):
  622. base_type_rec :
  623.             = base_type ( current_type );
  624.     field_name fromb lexpn;
  625. *$ES147  field_name :
  626.     = declared_components(base_type_rec)(field_name);
  627.     if ((nature ( current_type ) == 'subtype') ||
  628.         /*
  629.  *  if it is a formal parameter of some unconstrained type, the actual
  630.  *  parameter must have been constrained...
  631.  */
  632.     (        is_first_element
  633.         && is_formal ( first )
  634.         && is_unconstrained ( current_type ))){
  635. discr :
  636.         = discriminant_list ( base_type_rec );
  637. else
  638.     if (not exists
  639.         [ -, nam_list, - ] in invariant_part ( base_type_rec ) ,
  640.         name in nam_list | name = field_name ){
  641.         return TRUE;
  642.     }
  643. discr :
  644. = [];
  645.     }
  646. current_type :
  647.     = type_of ( field_name );
  648.  
  649.     /*
  650.  * Array or Slice case : if bound is dynamic, is must be constrained
  651.  */
  652.     ('[]', '[..]'):
  653.     *$ES147 (
  654. bounds :
  655.         = [];
  656.         (for i in index_types(current_type))
  657. [-, low, high] :
  658.         = signature (i);
  659. bounds +:
  660.         = [low, high];
  661.         end for;
  662.         if( exists bound in bounds || is_tuple(bound)
  663.         && (bound(1) = 'discr_rep')  && (bound(2) notin discr)){
  664.         return TRUE;
  665.     }
  666.  
  667.     if (op_name == '[]'){
  668. current_type :
  669.         = component_type ( current_type );
  670.     }
  671.  
  672.     *$ES147 )
  673.         /*
  674.  * Access case : cannot depend on a discriminant !
  675.  * Function call : idem
  676.  */
  677.     ('@', 'call'):
  678.     return     FALSE;
  679.  
  680.     /*
  681.  * Possible gap here
  682.  */
  683. else
  684.     return     FALSE;
  685. end case;
  686. is_first_element :
  687. =  FALSE;
  688.  
  689. }
  690.  
  691. return  FALSE; /* $ the initial guess */
  692.  
  693. #endif
  694. }
  695.  
  696. void linear(Symbol  expn ) /*;linear*/
  697. {
  698. /*  comment out for less warning messages from  CC
  699.     Symbol    op_name;
  700.     Symbol    exp1, exp2;
  701. */
  702.  
  703.     /*   Recursive function used by 'is_discriminant_dependent' to
  704.      *   flatten its argument. The grammar of interest for expn is :
  705.      *     expn ::= identifier
  706.      *           |  '.' rec_expr field_name
  707.      *           |  '[]' arr_expr index
  708.      *           |  '[..]' arr_expr slice
  709.      *           |  '@' expr
  710.      *           |  'call' identifier
  711.      */
  712.     chaos("linear(12) not implemented");
  713. #ifdef TBSN
  714.     if (is_identifier ( expn ) ){
  715.         return [ expn ];
  716.     }
  717.     else{
  718. [ op_name, exp1, exp2 ] :
  719.         = expn;
  720.     case op_name of
  721.         ('.'):
  722.         return linear(exp1)+[op_name]+linear(exp2);
  723.         ('[]', '[..]', '@', 'call'):
  724.         return linear(exp1)+[op_name];
  725. else
  726.     return [];
  727. end case;
  728.     }
  729. #endif
  730. }
  731.  
  732. static Symbol instantiate_type(Node type_node, Symbol g_name,Symbolmap type_map)
  733.   /*;instantiate_type*/
  734. {
  735.     /* Validate the     instantiation of a generic  type. The    actual must be
  736.      * a type mark.
  737.      */
  738.  
  739.     Symbol    actual_type;
  740.     int        nk;
  741.  
  742.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  instantiate_type");
  743.  
  744.     nk = N_KIND(type_node);
  745.     if (nk == as_name || nk == as_simple_name){
  746.         find_type(type_node);
  747.         actual_type = N_UNQ(type_node);
  748.         if (actual_type == symbol_any)                /* Not a type */
  749.             return (Symbol)0;
  750.         else 
  751.             return valid_type_instance(g_name, actual_type, type_map);
  752.     }
  753.     else{
  754. #ifdef ERRNUM
  755.         id_errmsgn(78, g_name, 58, current_node);
  756. #else
  757.         errmsg_id("invalid expression for instantiation of %", g_name,
  758.           "12.3", current_node);
  759. #endif
  760.         return (Symbol)0;
  761.     }
  762. }
  763.  
  764. static Symbol valid_type_instance(Symbol g_name, Symbol actual_type,
  765.   Symbolmap type_map)                        /*;valid_type_instance*/
  766. {
  767.     if (is_scalar_type(g_name))
  768.         return valid_scalar_instance(g_name, actual_type, type_map);
  769.     else if (is_access(g_name))
  770.         return valid_access_instance(g_name, actual_type, type_map);
  771.     else if (is_array(g_name))
  772.         return  valid_array_instance(g_name, actual_type, type_map);
  773.     else
  774.         return valid_priv_instance(g_name, actual_type, type_map);
  775. }
  776.  
  777. static Symbol valid_scalar_instance(Symbol g_name, Symbol actual_type,
  778.   Symbolmap type_map)                        /*;valid_scalar_instance*/
  779. {
  780.     /* Complete the validation of the instantiation of a generic scalar type.
  781.      * This procedure is also used to emit constraint checks on access types
  782.      * and array types.
  783.      */
  784.  
  785.     Symbol    g_type;
  786.  
  787.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : valid_scalar_instance");
  788.  
  789.     g_type = root_type(g_name); /*INTEGER, FLOAT, $FIXED, etc.*/
  790.     if (g_type == root_type(actual_type) && is_generic_type(g_name))
  791.         return actual_type;
  792.     else if (base_type(g_type) == base_type(actual_type)){
  793.         /* Checking instantiation of the designated type of an access type
  794.          * or  index type of an  array type. Verify that constraints match.
  795.          */
  796.         check_actual_constraint(g_name, actual_type);
  797.         return actual_type;
  798.     }
  799.     else if  ((is_fixed_type(g_type) && is_fixed_type(actual_type))
  800.       || (g_type == symbol_discrete_type  && is_discrete_type(actual_type)))
  801.         return actual_type;
  802.     else {
  803. #ifdef ERRNUM
  804.         id_errmsgn(79, g_name, 80, current_node);
  805. #else
  806.         errmsg_id("Invalid type for instantiation of %", g_name,
  807.           "12.3.2 - 12.3.5", current_node);
  808. #endif
  809.         return (Symbol)0;
  810.     }
  811. }
  812.  
  813. static void check_actual_constraint(Symbol g_type, Symbol a_type)
  814.   /*;check_actual_constraint*/
  815. {
  816.     /* Verify that the constraint on the designated type of an access type,
  817.      * or an index type of an array type, match the constraints on the cor-
  818.      * responding formal generic type. The types are known to be compatible.
  819.      */
  820.  
  821.     Node    n, d, g, a, t;
  822.     Tuple    g_discr_map, g_list, a_list;
  823.     Symbol    discr;
  824.     Tuple    g_info, a_info;
  825.     int        i;
  826.     Tuple    tup;
  827.     Fortup    ft;
  828.  
  829.     if (is_scalar_type(g_type)){
  830.         if (g_type == a_type) return;   /* simplest optimization. */
  831.         n = node_new(as_check_bounds);
  832.         g = new_name_node(g_type);
  833.         a = new_name_node(a_type);
  834.         N_AST1(n) = g;
  835.         N_AST2(n) = a;
  836.         instantiation_code_with(n);
  837.     }
  838.     else if (is_record(g_type)  && NATURE(g_type) == na_subtype){
  839.         /* Check that discriminants match.  */
  840.         if (NATURE(a_type) != na_subtype)
  841.             /* Mismatch was already signalled.  */
  842.             return;
  843.  
  844.         tup = SIGNATURE(g_type);
  845.         /* Compare the values of each discriminant. */
  846.         g_list = discriminant_list(base_type(g_type));
  847.         a_list = discriminant_list(base_type(a_type));
  848.         g_discr_map = (Tuple) SIGNATURE(g_type)[2];
  849.  
  850.         FORTUPI(discr=(Symbol), g_list, i, ft)
  851.             n = node_new(as_check_discr);
  852.             t = new_name_node(a_type);
  853.             d = new_name_node((Symbol) a_list[i]);
  854.             N_AST1(n) = discr_map_get(g_discr_map, discr);
  855.             N_AST2(n) = t;
  856.             N_AST3(n) = d;
  857.             instantiation_code_with(n);
  858.         ENDFORTUP(ft);
  859.     }
  860.     else if (is_array(g_type)) {
  861.         g_info = (Tuple) get_array_info(g_type);
  862.         a_info = (Tuple) get_array_info(a_type);
  863.  
  864.         for (i = 1; i <= tup_size(g_info); i++)
  865.             check_actual_constraint((Symbol) g_info[i], (Symbol) a_info[i]);
  866.     }
  867.     else if (is_access(g_type) )
  868.         check_actual_constraint(designated_type(g_type),
  869.           designated_type(a_type));
  870. }
  871.  
  872. static Symbol valid_priv_instance(Symbol g_name, Symbol actual_type,
  873.   Symbolmap type_map)                                /*;valid_priv_instance*/
  874. {
  875.     Symbol    g_type, actual_base;
  876.  
  877.     g_type = TYPE_OF(g_name);
  878.     actual_base = base_type(actual_type);
  879.  
  880.     if (TYPE_OF(actual_base) == symbol_incomplete){
  881. #ifdef ERRNUM
  882.         id_errmsgn(81, g_name, 58, current_node);
  883. #else
  884.         errmsg_id("Invalid use of incomplete type in instantiation of %",
  885.           g_name, "12.3", current_node);
  886. #endif
  887.         return (Symbol)0;
  888.     }
  889.     else if (private_ancestor(actual_base) != (Symbol)0 ){
  890. #ifdef ERRNUM
  891.         id_errmsgn(82, g_name, 58, current_node);
  892. #else
  893.         errmsg_id("Invalid use of private type in instantiation of %" , g_name,
  894.           "12.3", current_node);
  895. #endif
  896.         return (Symbol)0;
  897.     }
  898.     else if (g_type == symbol_private && is_limited_type(actual_type)) {
  899. #ifdef ERRNUM
  900.         id_errmsgn(83, g_name, 84, current_node);
  901. #else
  902.         errmsg_id("Expect non-limited type to instantiate %" , g_name,
  903.           "12.3.2", current_node);
  904. #endif
  905.         return (Symbol)0;
  906.     }
  907.     else if (is_record(g_name) && has_discriminants(g_name)
  908.         /*TBSL: check precdeence of next expr */
  909.       && (!is_record(actual_base) || !has_discriminants(actual_base)
  910.       || !is_valid_disc_instance(g_name, actual_base, type_map))) {
  911. #ifdef ERRNUM
  912.         id_errmsgn(85, g_name, 84, current_node);
  913. #else
  914.         errmsg_id("discriminant mismatch in instantiation of %", g_name,
  915.           "12.3.2", current_node);
  916. #endif
  917.         return (Symbol)0;
  918.     }
  919.     else if (has_discriminants(g_name) && NATURE(actual_type) == na_subtype) {
  920. #ifdef ERRNUM
  921.         id_errmsgn(86, g_name, 84, current_node);
  922. #else
  923.         errmsg_id("Instantiation of % must be unconstrained", g_name,
  924.           "12.3.2", current_node);
  925. #endif
  926.         return (Symbol)0;
  927.     }
  928.  
  929.     else if ((TA_CONSTRAIN & (int)misc_type_attributes(g_name))
  930.         /* The predefined packages cannot perform I/O on unconstrained
  931.          * types. This is caught explicitly here.
  932.          */
  933.       || streq(original_name(SCOPE_OF(g_name)) , "SEQUENTIAL_IO")
  934.       || streq(original_name(SCOPE_OF(g_name)) , "DIRECT_IO" )) {
  935.         if (is_unconstrained(actual_type)) {
  936. #ifdef ERRNUM
  937.             l_id_errmsgn(87, 88, g_name, 84, current_node);
  938. #else
  939.             errmsg_l_id("Usage of private type % requires instantiation with",
  940.               " constrained type", g_name, "12.3.2", current_node);
  941. #endif
  942.             return (Symbol)0;
  943.         }
  944.         else if (is_generic_type(actual_type)) {
  945.             /* instantiation of this actual will also have to be constrained
  946.              *    (see ACV test BC3205FB)
  947.              */
  948.             misc_type_attributes(actual_type) |= TA_CONSTRAIN;
  949.         }
  950.     }
  951.     return actual_type;
  952. }
  953.  
  954. static Symbol valid_access_instance(Symbol g_name, Symbol actual_type,
  955.   Symbolmap type_map)                        /*;valid_access_instance*/
  956. {
  957.     Symbol    g_type, designated_formal, designated_actual;
  958.  
  959.     g_type = (Symbol) designated_type(g_name);
  960.  
  961.     if (is_access(actual_type)){
  962.         /* the accessed actual type must be the proper instantiation
  963.            * of the accessed generic.
  964.            */
  965.         designated_formal = symbolmap_get(type_map, g_type);
  966.         if(designated_formal == (Symbol)0) designated_formal = g_type;
  967.         designated_actual = (Symbol) designated_type(actual_type);
  968.  
  969.         if (base_type(designated_formal) != base_type(designated_actual)) {
  970. #ifdef ERRNUM
  971.             id_id_errmsgn(89, designated_formal, g_name, 90, current_node);
  972. #else
  973.             errmsg_id_id("expect access to % to instantiate %" ,
  974.               designated_formal, g_name, "12.3.3", current_node);
  975. #endif
  976.             return (Symbol)0;
  977.         }
  978.         if (is_access(designated_formal)){
  979.             designated_formal = (Symbol) designated_type(designated_formal);
  980.             designated_actual = (Symbol) designated_type(designated_actual);
  981.         }
  982.         if ((can_constrain(designated_formal)
  983.           != can_constrain(designated_actual))){
  984. #ifdef ERRNUM
  985.             l_errmsgn(91, 92, 90, current_node);
  986. #else
  987.             errmsg_l("formal and actual designated types must be both ",
  988.               "constrained or unconstrained", "12.3.3", current_node);
  989. #endif
  990.             return (Symbol)0;
  991.         }
  992.         check_actual_constraint(designated_formal, designated_actual);
  993.  
  994.         return actual_type;
  995.     }
  996.     else{
  997. #ifdef ERRNUM
  998.         id_errmsgn(93, g_name, 94, current_node);
  999. #else
  1000.         errmsg_id("Expect access type to instantiate %", g_name, "12.3.5",
  1001.           current_node);
  1002. #endif
  1003.         return (Symbol)0;
  1004.     }
  1005. }
  1006.  
  1007. static Symbol valid_array_instance(Symbol g_name, Symbol actual_type,
  1008.   Symbolmap type_map)                        /*;valid_array_instance*/
  1009. {
  1010.     Symbol    g_type, g_comp, a_comp, t;
  1011.     int        i;
  1012.     Tuple    g_info, a_info, new_info;
  1013.     int        exists;
  1014.     Fortup    ft1;
  1015.     g_type = TYPE_OF(g_name);
  1016.  
  1017.     if ( !is_array(actual_type)) {
  1018. #ifdef ERRNUM
  1019.         id_errmsgn(95, g_name, 96, current_node);
  1020. #else
  1021.         errmsg_id("Expect array type to instantiate %", g_name, "12.3.4",
  1022.           current_node);
  1023. #endif
  1024.         return (Symbol)0;
  1025.     }
  1026.     else if (can_constrain(actual_type) && !can_constrain(g_name)){
  1027. #ifdef ERRNUM
  1028.         id_errmsgn(97, g_name, 96, current_node);
  1029. #else
  1030.         errmsg_id("Expect constrained array type to instantiate %", g_name,
  1031.           "12.3.4", current_node);
  1032. #endif
  1033.         return (Symbol)0;
  1034.     }
  1035.     else if (!can_constrain(actual_type) && can_constrain(g_name)){
  1036. #ifdef ERRNUM
  1037.         id_errmsgn(98, g_name, 96, current_node);
  1038. #else
  1039.         errmsg_id("Expect unconstrained array type to instantiate %", g_name,
  1040.           "12.3.4", current_node);
  1041. #endif
  1042.     }
  1043.     else if (no_dimensions(actual_type) != no_dimensions(g_type)) {
  1044. #ifdef ERRNUM
  1045.         id_errmsgn(99, g_name, 96, current_node);
  1046. #else
  1047.         errmsg_id("Dimensions of actual type do not match those of %", g_name,
  1048.           "12.3.4", current_node);
  1049. #endif
  1050.         return (Symbol)0;
  1051.     }
  1052.     else{
  1053.         /* Collect index types and component type. */
  1054.         g_info = get_array_info(g_type);
  1055.         a_info = get_array_info(actual_type);
  1056.         new_info = tup_new(tup_size(g_info));
  1057.         FORTUPI(t=(Symbol), g_info, i, ft1);
  1058.             new_info[i] = (char *) replace(t, type_map);
  1059.         ENDFORTUP(ft1);
  1060.         g_comp = (Symbol) new_info[tup_size(new_info)];
  1061.         a_comp = (Symbol)a_info[tup_size(a_info)];
  1062.  
  1063.         exists = FALSE;
  1064.         FORTUPI(t=(Symbol), new_info, i, ft1);
  1065.             if (!compatible_types(t, (Symbol) a_info[i])) {
  1066.                 exists = TRUE;
  1067.                 break;
  1068.             }
  1069.         ENDFORTUP(ft1);
  1070.         if (exists) {
  1071. #ifdef ERRNUM
  1072.             l_id_errmsgn(100, 101, g_name, 96, current_node);
  1073. #else
  1074.             errmsg_l_id("index or component type mismatch in instantiation",
  1075.               " of array type %", g_name, "12.3.4", current_node);
  1076. #endif
  1077.             return (Symbol)0;
  1078.         }
  1079.         /* Check components. */
  1080.         else if  (is_access(g_comp)     ?
  1081.           can_constrain(designated_type(g_comp)) !=
  1082.           can_constrain(designated_type(a_comp))
  1083.           : can_constrain(g_comp) !=can_constrain(a_comp) ) {
  1084. #ifdef ERRNUM
  1085.             l_errmsgn(102, 92, 96, current_node);
  1086. #else
  1087.             errmsg_l("formal and actual array component type must be both ",
  1088.               "constrained or unconstrained", "12.3.4", current_node);
  1089. #endif
  1090.             return (Symbol)0;
  1091.         }
  1092.         else {
  1093.             for (i = 1; i <= tup_size(new_info); i++)
  1094.                 check_actual_constraint((Symbol)new_info[i],(Symbol) a_info[i]);
  1095.             return actual_type;
  1096.         }
  1097.     }
  1098. }
  1099.  
  1100. static int is_valid_disc_instance(Symbol g_name, Symbol a_name,
  1101.   Symbolmap type_map)                            /*;is_valid_disc_instance*/
  1102. {
  1103.     /* checks that the formal and actual discriminant lists match in type
  1104.      * and position.
  1105.      */
  1106.  
  1107.     Tuple    g_list, a_list;
  1108.     Symbol    ad, gd;
  1109.     int        i;
  1110.     Symbol    t;
  1111.     Fortup    ft1;
  1112.     Symbol    gt, at;
  1113.  
  1114.     g_list = (Tuple) discriminant_list(g_name);
  1115.     a_list = (Tuple) discriminant_list(a_name);
  1116.     if (tup_size(g_list) != tup_size(a_list))
  1117.         return FALSE;
  1118.     else{
  1119.         FORTUPI(gd=(Symbol), g_list, i, ft1);
  1120.             ad = (Symbol)a_list[i];
  1121.             t = TYPE_OF(gd);            /* Type of discriminant */
  1122.             gt = symbolmap_get(type_map, t);    /* may be formal generic. */
  1123.             if (gt == (Symbol)0) gt = t;
  1124.             at = TYPE_OF(ad);            /* Base type of actual */
  1125.             if (base_type(gt) != base_type(at))   /* must match. */
  1126.                 return  FALSE;
  1127.             else{
  1128.                 check_actual_constraint(gt, at);    /* and constraints also. */
  1129.                 /* The discriminant names of the formal may have been used
  1130.                  * in a selector in the generic body.They must be mapped into
  1131.                  * the actual discriminants.
  1132.                  */
  1133.                 symbolmap_put(type_map, gd, ad);
  1134.             }
  1135.         ENDFORTUP(ft1);
  1136.     }
  1137.     return    TRUE;
  1138. }
  1139.  
  1140. static Tuple get_array_info(Symbol a_type)            /*;get_array_info*/
  1141. {
  1142.     /* Make sequence of index and component type marks, for comparing a
  1143.      * generic array type with its instantiation.
  1144.      */
  1145.  
  1146.     Tuple    tup;
  1147.  
  1148.     if (cdebug2 > 3 ) TO_ERRFILE("AT PROC :  get_array_info(a_type) ");
  1149.  
  1150.     tup = tup_copy(index_types(a_type));
  1151.     tup = tup_with(tup, (char *) component_type(a_type));
  1152.     return tup;
  1153. }
  1154.  
  1155. static void generic_subprog_instance(Node instance, Symbol g_name,
  1156.   Symbolmap type_map, int is_default)            /*;generic_subprog_instance*/
  1157. {
  1158.     /* Determine the operator, procedure, or attribute which is used to
  1159.      * instantiate a given generic subprogram parameter .
  1160.      *
  1161.      * To validate the new instance, we must first replace generic types by
  1162.      * actual types, to find the  instantiated signature of the  subprogram.
  1163.      */
  1164.  
  1165.     Tuple    new_sig, tup, new_types;
  1166.     Symbol    new_type, proc_name, new_name;
  1167.     Symbol    real_proc, f;
  1168.     Fortup    ft1;
  1169.     int        i;
  1170.  
  1171.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  generic_subprog_instance");
  1172.  
  1173.     if (SIGNATURE(g_name)!=(Tuple)0) {
  1174.         new_sig = tup_new(tup_size(SIGNATURE(g_name)));
  1175.         FORTUPI(f=(Symbol), SIGNATURE(g_name), i, ft1);
  1176.             tup = tup_new(4);
  1177.             tup[1] = ORIG_NAME(f);
  1178.             tup[2] = (char *) NATURE(f);
  1179.             tup[3] = (char *)replace(TYPE_OF(f), type_map);
  1180.             tup[4] = (char *) instantiate_tree((Node) default_expr(f),type_map);
  1181.             new_sig[i] = (char *) tup;
  1182.         ENDFORTUP(ft1);
  1183.     }
  1184.     new_type = replace(TYPE_OF(g_name), type_map);
  1185.     if (cdebug2 > 0 ) TO_ERRFILE("Gen.Subprog. has signature " );
  1186.     if (is_default)
  1187.         new_types = find_renamed_types(NATURE(g_name),
  1188.           new_sig, new_type, instance);
  1189.     else {    /* instantiate using actual */
  1190.         new_types = find_renamed_entity(NATURE(g_name),
  1191.           new_sig, new_type, instance);
  1192.         if (tup_size(new_types) == 0) {        /* renaming error; */
  1193. #ifdef ERRNUM
  1194.             id_errmsgn(103, g_name, 104, instance);
  1195. #else
  1196.             errmsg_id("invalid match for generic subprogram %",
  1197.               g_name, "12.3.6", instance);
  1198. #endif
  1199.             return;
  1200.         }
  1201.     }
  1202.     if (tup_size(new_types) != 0) {        /* no renaming error; */
  1203.         new_type = (Symbol) tup_frome(new_types);
  1204.         FORTUPI(tup=(Tuple), new_sig, i, ft1)
  1205.             tup[3] = new_types[i];
  1206.         ENDFORTUP(ft1)
  1207.     }
  1208.     if (N_KIND(instance) == as_simple_name) {
  1209.         /* It must be the name of an operator or user-defined procedure. */
  1210.         proc_name = N_UNQ(instance);
  1211.  
  1212.         /* instance is a renamed or derived subprogram. Subprogram calls */
  1213.         /* must use the name of the parent subprogram, so:*/
  1214.         if ((real_proc = ALIAS(proc_name)) != (Symbol)0)
  1215.             proc_name = real_proc;
  1216.         symbolmap_put(type_map, ALIAS(g_name), proc_name);
  1217.     }
  1218.     else {
  1219.         /* Instantiation by an attribute or an entry. */
  1220.         new_name = anon_proc_instance(g_name, new_sig, new_type);
  1221.         symbolmap_put(type_map, ALIAS(g_name), new_name);
  1222.         instantiation_code_with(make_rename_node(new_name, instance));
  1223.     }
  1224. }
  1225.  
  1226. static Tuple find_renamed_types(int kind, Tuple formals, Symbol ret,
  1227.   Node name_node)                                /*;find_renamed_types*/
  1228. {
  1229.     /* This procedure is finds the types for the default of a generic
  1230.      * subprogram parameter. In such a case, find_renamed_entity is called
  1231.      * from generic_subp_decl (generic declaration), and if no subprogram
  1232.      * is supplied at instantiation, this procedure is called to determine the
  1233.      * types of the new signature
  1234.      */
  1235.  
  1236.     Symbol    old1, e_name, typ, typ2, res, i;
  1237.     Node        e_node, attr_node, typ_node;
  1238.     int        attr;
  1239.     Tuple    types, tup;
  1240.     Fortup    ft1;
  1241.  
  1242.     types = tup_new(0);
  1243.  
  1244.     switch (N_KIND(name_node)) {
  1245.     case as_simple_name:
  1246.         /* suprogram name renames subprogram name. */
  1247.         old1 = N_UNQ(name_node);
  1248.         if (NATURE(old1) != na_op) {
  1249.             FORTUP(i=(Symbol), SIGNATURE(old1), ft1);
  1250.                 types = tup_with(types, (char *) TYPE_OF(i) );
  1251.             ENDFORTUP(ft1);
  1252.             types = tup_with(types, (char *) TYPE_OF(old1));
  1253.         }
  1254.         else {
  1255.             FORTUP(tup=(Tuple), formals, ft1);
  1256.                 types = tup_with(types, (char *) base_type((Symbol) tup[3]));
  1257.             ENDFORTUP(ft1);
  1258.             types = tup_with(types, (char *) base_type(ret));
  1259.         }
  1260.         break;
  1261.     case as_entry_name:
  1262.         /* Procedure renames a entry given by a qualified name. Find */
  1263.         /* the full entry (and task) name. */
  1264.         e_node = N_AST2(name_node);
  1265.         if (e_node != OPT_NODE) {
  1266.             e_name = N_UNQ(e_node);
  1267.             FORTUP(i=(Symbol), SIGNATURE(e_name), ft1)
  1268.                 types = tup_with(types, (char *) TYPE_OF(i) );
  1269.             ENDFORTUP(ft1)
  1270.             types = tup_with(types, (char *) symbol_none);
  1271.         }
  1272.         break;
  1273.     case as_attribute:
  1274.         /* The name can be an attribute, renaming a function. */
  1275.         attr_node = N_AST1(name_node);
  1276.         typ_node = N_AST2(name_node);
  1277.         attr = (int) attribute_kind(name_node);
  1278.         typ     = N_UNQ(typ_node);
  1279.         /* Find type returned by the attribute, and the required type of its
  1280.          * second argument.
  1281.          */
  1282.         if (attr == ATTR_SUCC || attr == ATTR_PRED) {
  1283.             typ2 = base_type(typ);
  1284.             res = base_type(typ);
  1285.         }
  1286.         else if (attr == ATTR_IMAGE) {
  1287.             typ2 = base_type(typ);
  1288.             res = symbol_string;
  1289.         }
  1290.         else if (attr == ATTR_VALUE) {
  1291.             typ2 = symbol_string;
  1292.             res = base_type(typ);
  1293.         }
  1294.         types = tup_new(2);
  1295.         types[1] = (char *) typ2;
  1296.         types[2] = (char *) res;
  1297.         break;
  1298.     default:
  1299. #ifdef DEBUG
  1300.         zpnod(name_node);
  1301. #endif
  1302.         chaos("unexpected node in find_renamed_types");
  1303.     }
  1304.     return types;
  1305. }
  1306.  
  1307. static Node make_rename_node(Symbol name, Node instance)  /*;make_rename_node*/
  1308. {
  1309.     /* Create a renaming node, for    use when a generic subprogram parameter
  1310.      * is instantiated with     an attribute or  an entry name. The rename node
  1311.      * of kind as_rename_sub_tr need not contain the spec node as this info
  1312.      * can be obtained by EXPAND from the symbol table but instead only contains
  1313.      * the unique name of the subprogram plus the instance info.
  1314.      */
  1315.  
  1316.     Node rename_node;
  1317.  
  1318.     rename_node = node_new(as_rename_sub_tr);
  1319.     N_AST2(rename_node) = instance;
  1320.     N_UNQ(rename_node) = name;
  1321.     return rename_node;
  1322. }
  1323.  
  1324. Symbol anon_proc_instance(Symbol g_name, Tuple sig, Symbol typ)
  1325. {
  1326.     /* When a generic subprogam is instantiated with an attribute or an
  1327.      * entry, we create a renaming declaration for an anonymous procedure.
  1328.      * The generic subprogram then renames this anonymous one.
  1329.      */
  1330.     Symbol    new_name, t, nam;
  1331.     Tuple    new_sig, tup, def;
  1332.     Fortup    ft1;
  1333.     int        kind;
  1334.     char    *id, *newat;
  1335.     char    *newat_str();
  1336.  
  1337.     new_name = sym_new(NATURE(g_name));
  1338.     newat = newat_str();
  1339.     dcl_put(DECLARED(scope_name), newat, new_name);
  1340.     TYPE_OF(new_name) = typ;
  1341.     ORIG_NAME(new_name) = strjoin(ORIG_NAME(g_name), newat);
  1342.  
  1343.     newscope(new_name);
  1344.     new_sig = tup_new(0);
  1345.  
  1346.     FORTUP(tup=(Tuple), sig, ft1);
  1347.         id = tup[1];
  1348.         kind = (int) tup[2];
  1349.         t = (Symbol) tup[3];
  1350.         def = (Tuple) tup[4];
  1351.         nam = find_new(id);
  1352.         NATURE(nam) = kind;
  1353.         TYPE_OF(nam) = t;
  1354.         SIGNATURE(nam) = def;
  1355.         new_sig = tup_with(new_sig, (char *) nam);
  1356.     ENDFORTUP(ft1);
  1357.     SIGNATURE(new_name) = new_sig;
  1358.     popscope();
  1359.  
  1360.     return new_name;
  1361. }
  1362.  
  1363. static void instantiation_code_with(Node node)
  1364. {
  1365.     /* add item to instantiation_code */
  1366.  
  1367.     int    n = (int) instantiation_code[0];
  1368.  
  1369.     if (instantiation_code_n >= n)
  1370.         instantiation_code = tup_exp(instantiation_code,
  1371.             (unsigned) n+INSTANTIATION_CODE_INC);
  1372.     instantiation_code[++instantiation_code_n] = (char *) node;
  1373. }
  1374.  
  1375. /* the following procedures formerly in undone.c have been put here
  1376.  * as the only references to them occurred in chapter 12 and they
  1377.  * should no longer be needed once that chapter fully translated.
  1378.  */
  1379. void is_identifier() {
  1380.     undone("is_identifier");
  1381. }
  1382. void is_tuple() {
  1383.     undone("is_tuple");
  1384. }
  1385.